perm filename GETPTS.F4[NEW,LCS]1 blob
sn#152183 filedate 1975-03-26 generic text, type T, neo UTF8
00100 CF SUBROUTINE GETPTS
00200 CF DIMENSION N(500),NP(500)
00300 CF COMMON/XRN/RN(4000) /KJY/ K,J
00400 CF COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
00500 CF 1/PTR/PWDS(250),ITEM,LL,I,IX
00600 CF EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R11,RJQ(9))
00700 CF 1,(R6,RJQ(4)),(N,RN(2500)),(NP,RN(3000))
00800 CF J=0
00810 CF K=0
00900 CF DO 1 M=1,ITEM
01000 CF L=PWDS(M)
01100 CF IF(RTLINE(L))GO TO 1
01200 CF RY=RN(L+1)
01300 CF IF(R6.LE.0)GO TO 9
01400 C CHECK CODE NUM
01500 CF IF(R6.NE.RY)GO TO 1
01600 CF9 IF(OUTLIM(R4,R5,RN(L+3)))GO TO 2
01700 C IN LIMITS?
01750 CF IF(JJ2)JJ2=M **** ALSO AT 6,8 AND 5 ***
01800 CF J=J+1
01900 CF N(J)=L+3
01920 CF K=K+1
01930 CF NP(K)=L
01940 C FOR USE IN JUSTIFY ROUTINE
02000 CF2 IF(RY.LT.4)GO TO 1
02100 CF IF(RY.GT.7)GO TO 1
02200 C TWO-ENDED ITEM?
02300 CF RZ=RN(L)
02400 C WD CNT
02500 CF GO TO(4,5,6,7),IFIX(RY)-3
02600 CF4 IF(RZ.GT.2)GO TO 5
02700 CF GO TO 1
02800 CF7 IF(RZ.GT.4)GO TO 5
02900 CF GO TO 1
03000 CF6 IF(RZ.LT.8)GO TO 8
03100 CF IF(RN(L+10).LT.30)GO TO 8
03200 CF IF(OUTLIM(R4,R5,RN(L+8)))GO TO 8
03300 CF J=J+1
03400 CF N(J)=L+8
03500 CF IF(RZ.LT.7)GO TO 5
03600 CF IF(OUTLIM(R4,R5,RN(L+9)))GO TO 5
03700 CF J=J+1
03800 CF N(J)=L+9
03900 CF5 IF(OUTLIM(R4,R5,RN(L+6)))GO TO 1
04000 CF J=J+1
04100 CF N(J)=L+6
04200 CF1 CONTINUE
04300 CF END
04400
04500 FUNCTION OUTLIM(A,B,C)
04600 OUTLIM=-1
04700 IF(C.LT.A)RETURN
04800 IF(C.GT.B)RETURN
04900 OUTLIM=0
05000 END
05100 CF SUBROUTINE MOVIT
05200 CF DIMENSION N(500)
05300 CF COMMON/XRN/RN(4000) /KJY/ DONT,J
05400 CF COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
05500 CF EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R9,RJQ(7))
05600 CF 1,(R6,RJQ(4)),(N,RN(2500)),(R8,RJQ(6))
05700 CF RDIS=(R9-R8)/(R5-R4)
05800 CF DO 1 K=1,J
05900 CF L=N(K)
06000 CF RA=RN(L)
06100 CF IF(OUTLIM(R4,R5,RA))GO TO 1
06200 CF IF(R9.NE.0)RA=(RA-R4)*RDIS
06300 CF RN(L)=R8+RA
06400 CF1 CONTINUE
06500 CF END
06600
06700 SUBROUTINE COPYIT
06800 COMMON/XRN/RN(4000) /KJY/ DONT,J
06900 COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
07000 1/PTR/PWDS(250),ITEM,LL,I,IX
07100 EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R7,RJQ(5))
07200 1,(R6,RJQ(4)),(N,RN(2500))
07300
07400 IM=ITEM
07500 DO 1 K=1,IM
07600 L=PWDS(K)
07700 IF(RTLINE(L))GO TO 1
07800 IF(OUTLIM(R4,R5,RN(L+3)))GO TO 1
07900 IF(R6.NE.0.AND.R6.NE.RN(L+1))GO TO 1
08000 M=RN(L)+2
08100 CALL LOOP(0,M,1,I,L,RN)
08200 ITEM=ITEM+1
08300 L=PWDS(ITEM)
08400 RN(L+2)=R7
08500 IF(JJ2)JJ2=ITEM
08600 I=I+M+1
08700 PWDS(ITEM+1)=I
08800 1 CONTINUE
08900 R2=R7
09000 END
09100 SUBROUTINE STFCH
09200 COMMON/XRN/RN(4000) /KJY/ DONT,JY /POSI/S(8),JJ2,P
09300 COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
09400 1/PTR/PWDS(250),ITEM,LL,I,IX
09500 EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R7,RJQ(5))
09600 1,(R6,RJQ(4))
09700
09800 DO 1 K=1,ITEM
09900 L=PWDS(K)
10000 IF(RTLINE(L))GO TO 1
10100 IF(OUTLIM(R4,R5,RN(L+3)))GO TO 1
10200 IF(RN(L+1).NE.R6.AND.R6.NE.0)GO TO 1
10300 C DIDN'T MATCH THE CODE NUM.
10350 IF(JJ2)JJ2=K
10400 RN(L+2)=R7
10500 1 CONTINUE
10600 END
10700
10800 SUBROUTINE UPDN
10900 COMMON/XRN/RN(4000) /KJY/ DONT,JY /POSI/S(8),JJ2,P
11000 COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
11100 1/PTR/PWDS(250),ITEM,LL,I,IX
11200 EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R11,RJQ(9))
11300 1,(R6,RJQ(4))
11400
11500 DO 1 K=1,ITEM
11600 L=PWDS(K)
11700 IF(RTLINE(L))GO TO 1
11800 RY=RN(L+1)
11900 IF(RY.GT.16)GO TO 1
12000 IF(RY.EQ.8)GO TO 1
12100 IF(RY.EQ.3)GO TO 1
12200 IF(RY.NE.R6.AND.R6.NE.0)GO TO 1
12300 C DIDN'T MATCH THE CODE NUM.
12400 IF(RY.EQ.4.AND.RN(L).LT.3)GO TO 1
12500 C A BAR LINE
12600 IF(OUTLIM(R4,R5,RN(L+3)))GO TO 2
12650 RN(L+4)=RN(L+4)+R11
12675 IF(JJ2)JJ2=K
12700 2 IF(RY.LT.4)GO TO 1
12800 IF(RY.GT.7)GO TO 1
12900 IF(RY.EQ.7.AND.RN(L).GT.4)GO TO 1
13000 C NO WIGGLE ON TRILL
13100 IF(RY.EQ.4.AND.RN(L+5).EQ.50)GO TO 1
13200 C CRESC. OR BOX
13300 IF(OUTLIM(R4,R5,RN(L+6)))GO TO 1
13350 RN(L+5)=RN(L+5)+R11
13360 IF(JJ2)JJ2=K
13400 1 CONTINUE
13500 END
13600